--书上例子的简洁版
import Data.Array (Array(..), (!), bounds, elems, indices,ixmap, listArray)

import Control.Applicative ((<$>))
import Control.Monad (forM_)
import Data.Char (digitToInt)
import Data.Ix (Ix(..))
import Data.List (foldl', group, sort, sortBy, tails)
import Data.Maybe (catMaybes, listToMaybe)
import Data.Ratio (Ratio)
import Data.Word (Word8)
import System.Environment (getArgs)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M



checkDigit :: (Integral a) => [a] -> a
checkDigit ds = 10 - productSum `mod` 10 
    where productSum = sum (mapEveryOther (*3) (reverse ds))
    
--checkDigit :: (Integral a) => [a] -> a
--checkDigit ds = productSum `mod` 10 `mod` 10
--    where productSum = sum (mapEveryOther (*3) (reverse ds))    


mapEveryOther :: (a -> a) -> [a] -> [a]
mapEveryOther f = zipWith ($) (cycle [f,id])


leftOddList = ["0001101", "0011001", "0010011", "0111101", "0100011",
               "0110001", "0101111", "0111011", "0110111", "0001011"]
               
rightList = map complement <$> leftOddList
    where complement '0' = '1'
          complement '1' = '0'

leftEvenList = map reverse rightList

parityList = ["111111", "110100", "110010", "110001", "101100", "100110", "100011", "101010", "101001", "100101"]



listToArray :: [a] -> Array Int a
listToArray xs = listArray (0,l-1) xs
    where l = length xs

leftOddCodes, leftEvenCodes, rightCodes, parityCodes :: Array Int String

leftOddCodes    = listToArray leftOddList
leftEvenCodes   = listToArray leftEvenList
rightCodes      = listToArray rightList
parityCodes     = listToArray parityList    


foldA :: Ix k => (a -> b -> a) -> a -> Array k b -> a
foldA f s a = go s (indices a)
    where go s (j:js) = let s' = f s (a ! j)
                        in s' `seq` go s' js
          go s _ = s

-- | Strict left fold using the first element of the array as its
-- starting value, similar to foldl1 on lists.
foldA1 :: Ix k => (a -> a -> a) -> Array k a -> a
foldA1 f a = foldA f (a ! fst (bounds a)) a

type Run = Int
type RunLength a = [(Run, a)]

runLength :: Eq a => [a] -> RunLength a
runLength = map rle . group
    where rle xs = (length xs, head xs)
    
runLengths :: Eq a => [a] -> [Run]
runLengths = map fst . runLength    



data Bit = Zero | One
           deriving (Eq, Show)

threshold :: (Ix k, Integral a) => Double -> Array k a -> Array k Bit
threshold n a = binary <$> a
    where binary i | i < pivot  = Zero
                    | otherwise  = One
          pivot    = round $ least + (greatest - least) * n
          least    = fromIntegral $ choose (<) a
          greatest = fromIntegral $ choose (>) a
          choose f = foldA1 $ \x y -> if f x y then x else y
          
type Score = Ratio Int
type ScoreTable = [[Score]]
scaleToOne :: [Run] -> [Score]
scaleToOne xs = map divide xs
    where divide d = fromIntegral d / divisor
          divisor = fromIntegral (sum xs)

asSRL :: [String] -> ScoreTable
asSRL = map (scaleToOne . runLengths)

leftOddSRL = asSRL leftOddList
leftEvenSRL = asSRL leftEvenList
rightSRL = asSRL rightList
paritySRL = asSRL parityList



distance xs1 xs2 = sum . fmap abs $  zipWith (-) xs1 xs2

type Digit1 = Int
bestScores :: ScoreTable -> [Run] -> [(Score, Digit1)]
bestScores srl ps = take 3 . sort $ scores
    where scores = zip [distance d (scaleToOne ps) | d <- srl] digits
          digits = [0..9]
          
bestScores2 :: ScoreTable -> [Run] -> [(Score, Digit1)]
bestScores2 srl ps = sort $ scores
    where scores = zip [distance d (scaleToOne ps) | d <- srl] digits
          digits = [0..9]          

          
data Parity a = Even a | Odd a | None a
                deriving (Show)

fromParity :: Parity a -> a
fromParity (Even a) = a
fromParity (Odd a) = a
fromParity (None a) = a

parityMap :: (a -> b) -> Parity a -> Parity b
parityMap f (Even a) = Even (f a)
parityMap f (Odd a) = Odd (f a)
parityMap f (None a) = None (f a)

instance Functor Parity where
    fmap = parityMap          
          
on :: (a -> a -> b) -> (c -> a) -> c -> c -> b
on f g x y = g x `f` g y

compareWithoutParity = compare `on` fromParity


type Digit = Int

bestLeft :: [Run] -> [Parity (Score, Digit)]
bestLeft ps = sortBy compareWithoutParity
          ((map Odd (bestScores leftOddSRL ps)) ++
            (map Even (bestScores leftEvenSRL ps)))

bestRight :: [Run] -> [Parity (Score, Digit)]
bestRight = map None . bestScores rightSRL     



             
--根据某种条件，分割列表；该条件是灵活可变的，可以是数量，可以是数值。             
chunkWith :: ([a] -> ([a], [a])) -> [a] -> [[a]]
chunkWith _ [] = []
chunkWith f xs = let (h, t) = f xs
             in h : chunkWith f t

--chunkWith的特化版，根据数量分割
chunksOf :: Int -> [a] -> [[a]]
chunksOf n = chunkWith (splitAt n)


candidateDigits :: RunLength Bit -> [[Parity Digit]]
--candidateDigits ((_, One):_) = []
candidateDigits rle | length rle < 59 = []
candidateDigits rle
    | any null match = [[None 3]]
    | otherwise      = map (map (fmap snd)) match
  where match = map bestLeft left ++ map bestRight right
        left = chunksOf 4 . take 24 . drop 3 $ runLengths
        right = chunksOf 4 . take 24 . drop 32 $ runLengths
        runLengths = map fst rle
        
        
candidateDigits2 :: RunLength Char -> [[Parity Digit]]
--candidateDigits ((_, One):_) = []
candidateDigits2 rle | length rle < 59 = []
candidateDigits2 rle
    | any null match = [[None 3]]
    | otherwise      = map (map (fmap snd)) match
  where match = map bestLeft left ++ map bestRight right
        left = chunksOf 4 . take 24 . drop 3 $ runLengths
        right = chunksOf 4 . take 24 . drop 32 $ runLengths
        runLengths = map fst rle        
toBit 0 = Zero
toBit _ = One        
chrToBit '0' = Zero
chrToBit _ = One   

type Map a = M.Map Digit [a]
type DigitMap = Map Digit
type ParityMap = Map (Parity Digit)

updateMap :: Parity Digit       -- ^ new digit
          -> Digit              -- ^ existing key
          -> [Parity Digit]     -- ^ existing digit sequence
          -> ParityMap          -- ^ map to update
          -> ParityMap
updateMap digit key seq = insertMap key (fromParity digit) (digit:seq)
 
insertMap :: Digit -> Digit -> [a] -> Map a -> Map a
insertMap key digit val m = val `seq` M.insert key' val m
    where key' = (key + digit) `mod` 10

useDigit :: ParityMap -> ParityMap -> Parity Digit -> ParityMap
useDigit old new digit =
    new `M.union` M.foldWithKey (updateMap digit) M.empty old   


incorporateDigits :: ParityMap -> [Parity Digit] -> ParityMap
incorporateDigits old digits = foldl' (useDigit old) M.empty digits

finalDigits :: [[Parity Digit]] -> ParityMap
finalDigits = foldl' incorporateDigits (M.singleton 0 [])
            . mapEveryOther (map (fmap (*3)))  

firstDigit :: [Parity a] -> Digit
firstDigit = snd
           . head
           . bestScores paritySRL
           . runLengths
           . map parityBit
           . take 6
  where parityBit (Even _) = Zero
        parityBit (Odd _) = One

addFirstDigit :: ParityMap -> DigitMap
addFirstDigit = M.foldWithKey updateFirst M.empty

updateFirst :: Digit -> [Parity Digit] -> DigitMap -> DigitMap
updateFirst key seq = insertMap key digit (digit:renormalize qes)
  where renormalize = mapEveryOther (`div` 3) . map fromParity
        digit = firstDigit qes
        qes = reverse seq

buildMap :: [[Parity Digit]] -> DigitMap
buildMap = M.mapKeys (realCheckDigit)
         . addFirstDigit
         . finalDigits
        where realCheckDigit c = (10 - c) `mod` 10   
       
solve :: [[Parity Digit]] -> [[Digit]]
solve [] = []
solve xs = catMaybes $ map (addCheckDigit m) checkDigits
    where checkDigits = map fromParity (last xs)
          m = buildMap (init xs)
          addCheckDigit m k = (++[k]) <$> M.lookup k m            

-- =============================================================================================================================
decodeEAN13:: String -> [[Digit]]
decodeEAN13 bitsAll = solve $  candidateDigits $ runLength (fmap chrToBit bitsAll)


decodeEAN13_2:: String -> [[Digit]]
decodeEAN13_2 bitsAll = solve $  candidateDigits2 $ runLength $ bitsAll


decodeEAN13_3:: String -> [[Digit]]
decodeEAN13_3  = solve .  candidateDigits2 . runLength 

-- =============================================================================================================================

encodeEAN13 :: String -> String
encodeEAN13 = concat . encodeDigits . map digitToInt

-- | This function computes the check digit; don't pass one in.
encodeDigits :: [Int] -> [String]
encodeDigits s@(first:rest) =
    outerGuard : lefties ++ centerGuard : righties ++ [outerGuard]
    where (left, right) = splitAt 6 rest
          lefties = zipWith leftEncode (parityCodes ! first) left
          righties = map rightEncode (right ++ [checkDigit s])

leftEncode :: Char -> Int -> String
leftEncode '1' = (leftOddCodes !)
leftEncode '0' = (leftEvenCodes !)

rightEncode :: Int -> String
rightEncode = (rightCodes !)

outerGuard = "101"
centerGuard = "01010"

-- =============================================================================================================================
{-
*Main> x1 = encodeEAN13 "1111111111116"
*Main> x1
"101001100100110010110011001100101100110110011010101100110110011011001101100110110011010100001101100101"
*Main> decodeEAN13  x1
[[1,1,1,1,1,1,1,1,1,1,1,1,6],[7,4,0,1,1,1,1,1,1,1,1,1,2]]



-}



bitsEnd="101"
bitsBegin="101"
bitsCenter="01010"
--bitsCenter="10101"
bits1R = "1100110"
bits6R = "1010000"
bits1L = "0001101"
bitsRight = bits1R ++ bits1R ++ bits1R ++ bits1R ++ bits1R ++ bits6R
--bitsLeft = bits1L ++ bits1L ++ bits1L ++ bits1L ++ bits1L ++ bits1L
bitsLeft = "0011001" ++ "0011001" ++ "0110011" ++ "0011001" ++ "0110011" ++ "0110011" 

bitsAll = bitsBegin ++ bitsLeft ++ bitsCenter ++ bitsRight ++ bitsEnd

aa = runLength bitsAll --aa :: RunLength Char
c =  map (fst . head) (group aa) 
--c等价于b
bb = map fst aa
right = chunksOf 4 . take 24 . drop 32  $ bb
right1= map bestRight right

left = chunksOf 4 . take 24 . drop 3 $ bb
left1 = map bestLeft left

match = left1 ++ right1
digits = map (map (fmap snd)) match



